home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-elk / proc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-12  |  14.2 KB  |  562 lines
  1. /* Eval, funcall, apply, map, lambda, macro, etc.
  2.  */
  3.  
  4. #include "scheme.h"
  5. #if ZELK
  6. # include <zelk.h>
  7. #endif
  8.  
  9. #ifdef USE_ALLOCA
  10. #  define MAX_ARGS_ON_STACK  4
  11. #else
  12. #  define MAX_ARGS_ON_STACK  8
  13. #endif
  14.  
  15. char *Error_Tag;
  16.  
  17. /* Tail_Call indicates whether we are executing the last form in a
  18.  * sequence of forms.  If it is true and we are about to call a compound
  19.  * procedure, we are allowed to check whether a tail-call can be
  20.  * performed instead.
  21.  */
  22. int Tail_Call = 0;
  23.  
  24. Object Sym_Lambda,
  25.        Sym_Macro;
  26.  
  27. static Object tc_fun, tc_argl, tc_env;
  28.  
  29. Object Macro_Expand();
  30.  
  31. Init_Proc () {
  32.     Define_Symbol (&Sym_Lambda, "lambda");
  33.     Define_Symbol (&Sym_Macro, "macro");
  34. }
  35.  
  36. Check_Procedure (x) Object x; {
  37.     register t = TYPE(x);
  38.  
  39.     if (t != T_Primitive && t != T_Compound)
  40.     Wrong_Type_Combination (x, "procedure");
  41.     if (t == T_Primitive && PRIM(x)->disc == NOEVAL)
  42.     Primitive_Error ("invalid procedure: ~s", x);
  43. }
  44.  
  45. Object P_Procedurep (x) Object x; {
  46.     register t = TYPE(x);
  47.     return t == T_Primitive || t == T_Compound || t == T_Control_Point
  48.      ? True : False;
  49. }
  50.  
  51. Object P_Primitivep (x) Object x; {
  52.     return TYPE(x) == T_Primitive ? True : False;
  53. }
  54.  
  55. Object P_Compoundp (x) Object x; {
  56.     return TYPE(x) == T_Compound ? True : False;
  57. }
  58.  
  59. Object P_Macrop (x) Object x; {
  60.     return TYPE(x) == T_Macro ? True : False;
  61. }
  62.  
  63. Object Make_Compound () {
  64.     Object proc;
  65.  
  66.     proc = Alloc_Object (sizeof (struct S_Compound), T_Compound, 0);
  67.     COMPOUND(proc)->closure = COMPOUND(proc)->env = COMPOUND(proc)->name = Null;
  68.     return proc;
  69. }
  70.  
  71. Object Make_Primitive (fun, name, min, max, disc) Object (*fun)(); char *name;
  72.     enum discipline disc; {
  73.     Object prim;
  74.     register struct S_Primitive *pr;
  75.  
  76.     prim = Alloc_Object (sizeof (struct S_Primitive), T_Primitive, 0);
  77.     pr = PRIM(prim);
  78.     pr->tag = Null;
  79.     pr->fun = fun;
  80.     pr->name = name;
  81.     pr->minargs = min;
  82.     pr->maxargs = max;
  83.     pr->disc = disc;
  84.     return prim;
  85. }
  86.  
  87. Object Eval (form) Object form; {
  88.     register t;
  89.     register struct S_Symbol *sym;
  90.     Object fun, binding, args, ret;
  91.     GC_Node;
  92.  
  93. again:
  94.     t = TYPE(form);
  95.     if (t == T_Symbol) {
  96.     sym = SYMBOL(form);
  97.     if (EQ(sym->value,Unbound)) {
  98.         binding = Lookup_Symbol (form, 1);
  99.         sym->value = Cdr (binding);
  100.     }
  101.     ret = sym->value;
  102.     if (TYPE(ret) == T_Autoload)
  103.         ret = Do_Autoload (form, ret);
  104.     return ret;
  105.     }
  106.     if (t != T_Pair) {
  107.     if (t == T_Null)
  108.         Primitive_Error ("no subexpression in procedure call");
  109.     if (t == T_Vector)
  110.         Primitive_Error ("unevaluable object: ~s", form);
  111.     return form;
  112.     }
  113.     if (Stack_Size () > Max_Stack)
  114.     Uncatchable_Error ("Out of stack space");
  115.     GC_Link (form);
  116.     fun = Eval (Car (form));
  117.     args = Cdr (form);
  118.     Check_List (args);
  119.     if (TYPE(fun) == T_Macro) {
  120.     form = Macro_Expand (fun, args);
  121.     GC_Unlink;
  122.     goto again;
  123.     }
  124.     ret = Funcall (fun, args, 1);
  125.     GC_Unlink;
  126.     return ret;
  127. }
  128.  
  129. Object P_Eval (argc, argv) Object *argv; {
  130.     Object ret, oldenv;
  131.     GC_Node;
  132.  
  133.     if (argc == 1)
  134.     return Eval (argv[0]);
  135.     Check_Type (argv[1], T_Environment);
  136.     oldenv = The_Environment;
  137.     GC_Link (oldenv);
  138.     Switch_Environment (argv[1]);
  139.     ret = Eval (argv[0]);
  140.     Switch_Environment (oldenv);
  141.     GC_Unlink;
  142.     return ret;
  143. }
  144.  
  145. Object P_Apply (argc, argv) Object *argv; {
  146.     Object ret, list, tail, cell, last;
  147.     register i;
  148.     GC_Node3;
  149.  
  150.     Check_Procedure (argv[0]);
  151.     /* Make a list of all args but the last, then append the
  152.      * last arg (which must be a proper list) to this list.
  153.      */
  154.     list = tail = last = Null;
  155.     GC_Link3 (list, tail, last);
  156.     for (i = 1; i < argc-1; i++, tail = cell) {
  157.     cell = Cons (argv[i], Null);
  158.     if (Nullp (list))
  159.         list = cell;
  160.     else
  161.         (void)P_Setcdr (tail, cell);
  162.     }
  163.     for (last = argv[argc-1]; !Nullp (last); last = Cdr (last), tail = cell) {
  164.     cell = Cons (P_Car (last), Null);
  165.     if (Nullp (list))
  166.         list = cell;
  167.     else
  168.         (void)P_Setcdr (tail, cell);
  169.     }
  170.     ret = Funcall (argv[0], list, 0);
  171.     GC_Unlink;
  172.     return ret;
  173. }
  174.  
  175. Arglist_Length (list) Object list; {
  176.     Object tail;
  177.     register i;
  178.  
  179.     for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
  180.     ;
  181.     if (Nullp (tail))
  182.     return i;
  183.     Primitive_Error ("argument list is improper");
  184.     /*NOTREACHED*/
  185. }
  186.  
  187. Object Funcall_Primitive (fun, argl, eval) Object fun, argl; {
  188.     register struct S_Primitive *prim;
  189.     register argc, i;
  190.     char *last;
  191.     Object *argv;
  192.     Object abuf[MAX_ARGS_ON_STACK], ret;
  193.     GC_Node2; GCNODE gcv;
  194.     TC_Prolog;
  195.     Alloca_Begin;
  196.  
  197.     prim = PRIM(fun);
  198.     last = Error_Tag;
  199.     Error_Tag = prim->name;
  200.     argc = Arglist_Length (argl);
  201.     if (argc < prim->minargs
  202.         || (prim->maxargs != MANY && argc > prim->maxargs))
  203.     Primitive_Error ("wrong number of arguments");
  204.     if (prim->disc == NOEVAL) {
  205.     ret = (prim->fun)(argl);
  206.     } else {
  207.     /* Tail recursion is not possible while evaluating the arguments
  208.      * of a primitive procedure.
  209.      */
  210.     TC_Disable;
  211.     if (argc <= MAX_ARGS_ON_STACK)
  212.         argv = abuf;
  213.     else
  214.         Alloca (argv, Object*, argc * sizeof (Object));
  215.     GC_Link2 (argl, fun);
  216.     gcv.gclen = 1; gcv.gcobj = argv; gcv.next = &gc2; GC_List = &gcv;
  217.     for (i = 0; i < argc; i++, argl = Cdr (argl)) {
  218.         argv[i] = eval ? Eval (Car (argl)) : Car (argl);
  219.         gcv.gclen++;
  220.     }
  221.     TC_Enable;
  222.     prim = PRIM(fun);   /* fun has possibly been moved during gc */
  223.     if (prim->disc == VARARGS) {
  224.         ret = (prim->fun)(argc, argv);
  225.     }
  226. # ifdef ZELK 
  227.         else if (prim->disc == FOREIGN) {
  228.             ret = ZLforcall(prim->name,(function *)prim->fun,prim->forfunargs,
  229.                             argc,argv);
  230.         }
  231. # endif
  232.         else {
  233.         switch (argc) {
  234.         case 0:
  235.         ret = (prim->fun)(); break;
  236.         case 1:
  237.         ret = (prim->fun)(argv[0]); break;
  238.         case 2:
  239.         ret = (prim->fun)(argv[0], argv[1]); break;
  240.         case 3:
  241.         ret = (prim->fun)(argv[0], argv[1], argv[2]); break;
  242.         case 4:
  243.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3]); break;
  244.         case 5:
  245.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4]);
  246.         break;
  247.         case 6:
  248.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  249.                           argv[5]); break;
  250.         case 7:
  251.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  252.                           argv[5], argv[6]); break;
  253.         case 8:
  254.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  255.                           argv[5], argv[6], argv[7]); break;
  256.         case 9:
  257.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  258.                           argv[5], argv[6], argv[7], argv[8]); break;
  259.         case 10:
  260.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  261.                           argv[5], argv[6], argv[7], argv[8], argv[9]);
  262.         break;
  263.         default:
  264.         Panic ("too many args for primitive");
  265.         }
  266.     }
  267.     GC_Unlink;
  268.     Alloca_End;
  269.     }
  270.     Error_Tag = last;
  271.     return ret;
  272. }
  273.  
  274. /* If we are in a tail recursion, we are reusing the old procedure
  275.  * frame; we just assign new values to the formal parameters:
  276.  */
  277. #define Lambda_Bind(var,val)\
  278. if (tail_calling) {\
  279.     newframe = Add_Binding (newframe, var, val);\
  280. } else {\
  281.     frame = Add_Binding (frame, var, val);\
  282. }
  283.  
  284. Object Funcall_Compound (fun, argl, eval) Object fun, argl; {
  285.     register argc, min, max, i, tail_calling = 0;
  286.     Object *argv, abuf[MAX_ARGS_ON_STACK], rest, ret, frame,
  287.     tail, tail_call_env, oldenv, newframe;
  288.     GC_Node6; GCNODE gcv;
  289.     TC_Prolog;
  290.     Alloca_Begin;
  291.  
  292. #ifdef lint
  293.     tail_call_env = Null;
  294. #endif
  295.     frame = oldenv = tail = newframe = Null;
  296.     GC_Link6 (argl, oldenv, frame, tail, fun, newframe);
  297. again:
  298.     argc = Arglist_Length (argl);
  299.     min = COMPOUND(fun)->min_args;
  300.     max = COMPOUND(fun)->max_args;
  301.     if (argc < min)
  302.     Primitive_Error ("too few arguments for ~s", fun);
  303.     if (max >= 0 && argc > max)
  304.     Primitive_Error ("too many arguments for ~s", fun);
  305.     if (tail_calling) {
  306.     tail = The_Environment;
  307.     Switch_Environment (tail_call_env);
  308.     } else {
  309.     if (argc <= MAX_ARGS_ON_STACK)
  310.         argv = abuf;
  311.     else
  312.         Alloca (argv, Object*, argc * sizeof (Object));
  313.     }
  314.     TC_Disable;
  315.     gcv.gclen = 1; gcv.gcobj = argv; gcv.next = &gc6; GC_List = &gcv;
  316.     for (i = 0; i < argc; i++, argl = Cdr (argl)) {
  317.     argv[i] = eval ? Eval (Car (argl)) : Car (argl);
  318.     gcv.gclen++;
  319.     }
  320.     TC_Enable;
  321.     if (tail_calling)
  322.     Switch_Environment (tail);
  323.     tail = Car (Cdr (COMPOUND(fun)->closure));
  324.     for (i = 0; i < min; i++, tail = Cdr (tail))
  325.     Lambda_Bind (Car (tail), argv[i]);
  326.     if (max == -1) {
  327.     rest = P_List (argc-i, argv+i);
  328.     Lambda_Bind (tail, rest);
  329.     }
  330.     if (tail_calling) {
  331.     Pop_Frame ();
  332.     Push_Frame (newframe);
  333.     } else {
  334.     oldenv = The_Environment;
  335.     Switch_Environment (COMPOUND(fun)->env);
  336.         Push_Frame (frame);
  337.     }
  338.  
  339.     Tail_Call = 1;
  340.     ret = Begin (Cdr (Cdr (COMPOUND(fun)->closure)));
  341.     /*
  342.      * If evaluation of the function body returned a T_Special object,
  343.      * a tail-call has been taken place.  If it is a tail-call to a
  344.      * different function, just return, otherwise unpack new arguments
  345.      * and environment and jump to the beginning.
  346.      */
  347.     if (TYPE(ret) == T_Special && EQ(fun, tc_fun)) {
  348.     argl = tc_argl;
  349.     tail_call_env = tc_env;
  350.     tail_calling = 1;
  351.     eval = 1;
  352.     newframe = Null;
  353.     goto again;
  354.     }
  355.     Tail_Call = 0;
  356.     Pop_Frame ();
  357.     Switch_Environment (oldenv);
  358.     GC_Unlink;
  359.     Alloca_End;
  360.     return ret;
  361. }
  362.  
  363. Object Funcall (fun, argl, eval) Object fun, argl; {
  364.     register t;
  365.     register GCNODE *p;
  366.     Object ret, env;
  367.     Tag_Node;
  368.  
  369.     t = TYPE(fun);
  370.     /* Search upwards in the GC list for a TAG frame pointing to
  371.      * the function we are abount to call.  Stop if a TAG frame
  372.      * is encountered that points to a function call that is not
  373.      * in a tail-call position.
  374.      *
  375.      * If the search succeeds, package up function, actual arguments,
  376.      * and environment, and return a T_Special object.
  377.      */
  378.     if (Tail_Call && eval && t == T_Compound)
  379.     for (p = GC_List; p && p->gclen != TAG_FUN; p = p->next)
  380.         if (p->gclen == TAG_TCFUN && EQ(*(p->gcobj), fun)) {
  381.         SET(ret, T_Special, 0);
  382.         tc_fun = fun; tc_argl = argl; tc_env = The_Environment;
  383.         return ret;
  384.         }
  385.     env = The_Environment;
  386.     Tag_Link (argl, fun, env);
  387.     if (t == T_Primitive) {
  388.     ret = Funcall_Primitive (fun, argl, eval);
  389.     } else if (t == T_Compound) {
  390.     ret = Funcall_Compound (fun, argl, eval);
  391.     } else if (t == T_Control_Point) {
  392.     Funcall_Control_Point (fun, argl, eval);
  393.     /*NOTREACHED*/
  394.     } else Primitive_Error ("application of non-procedure: ~s", fun);
  395.     Tag_Unlink;
  396.     return ret;
  397. }
  398.  
  399. Check_Formals (x, min, max) Object x; int *min, *max; {
  400.     Object s, t1, t2;
  401.  
  402.     *min = *max = 0;
  403.     for (t1 = Car (x); !Nullp (t1); t1 = Cdr (t1)) {
  404.         s = TYPE(t1) == T_Pair ? Car (t1) : t1;
  405.     Check_Type (s, T_Symbol);
  406.     for (t2 = Car (x); t2 != t1; t2 = Cdr (t2))
  407.         if (EQ(s, Car (t2)))
  408.         Primitive_Error ("~s: duplicate variable binding", s);
  409.     if (TYPE(t1) != T_Pair)
  410.         break;
  411.     (*min)++; (*max)++;
  412.     }
  413.     if (TYPE(t1) == T_Symbol)
  414.     *max = -1;
  415.     else if (!Nullp (t1))
  416.     Wrong_Type_Combination (t1, "list or symbol");
  417. }
  418.  
  419. Object P_Lambda (argl) Object argl; {
  420.     Object proc, closure;
  421.     GC_Node2;
  422.  
  423.     proc = Null;
  424.     GC_Link2 (argl, proc);
  425.     proc = Make_Compound ();
  426.     closure = Cons (Sym_Lambda, argl);
  427.     COMPOUND(proc)->closure = closure;
  428.     COMPOUND(proc)->env = The_Environment;
  429.     Check_Formals (argl, &COMPOUND(proc)->min_args,
  430.     &COMPOUND(proc)->max_args);
  431.     GC_Unlink;
  432.     return proc;
  433. }
  434.  
  435. Object P_Procedure_Lambda (p) Object p; {
  436.     Check_Type (p, T_Compound);
  437.     return Copy_List (COMPOUND(p)->closure);
  438. }
  439.  
  440. Object P_Procedure_Env (p) Object p; {
  441.     Check_Type (p, T_Compound);
  442.     return COMPOUND(p)->env;
  443. }
  444.  
  445. Object General_Map (argc, argv, accum) Object *argv; register accum; {
  446.     register i;
  447.     Object *args;
  448.     Object head, list, tail, cell, arglist, val;
  449.     GC_Node2; GCNODE gcv;
  450.     Alloca_Begin;
  451.  
  452.     Check_Procedure (argv[0]);
  453.     Alloca (args, Object*, (argc-1) * sizeof (Object));
  454.     list = tail = Null;
  455.     GC_Link2 (list, tail);
  456.     gcv.gclen = argc; gcv.gcobj = args; gcv.next = &gc2; GC_List = &gcv;
  457.     while (1) {
  458.     for (i = 1; i < argc; i++) {
  459.         head = argv[i];
  460.         if (Nullp (head)) {
  461.         GC_Unlink;
  462.         Alloca_End;
  463.         return list;
  464.         }
  465.         Check_Type (head, T_Pair);
  466.         args[i-1] = Car (head);
  467.         argv[i] = Cdr (head);
  468.     }
  469.     arglist = P_List (argc-1, args);
  470.     val = Funcall (argv[0], arglist, 0);
  471.     if (!accum)
  472.         continue;
  473.     cell = Cons (val, Null);
  474.     if (Nullp (list))
  475.         list = cell;
  476.     else
  477.         (void)P_Setcdr (tail, cell);
  478.     tail = cell;
  479.     }
  480.     /*NOTREACHED*/
  481. }
  482.  
  483. Object P_Map (argc, argv) Object *argv; {
  484.     return General_Map (argc, argv, 1);
  485. }
  486.  
  487. Object P_For_Each (argc, argv) Object *argv; {
  488.     return General_Map (argc, argv, 0);
  489. }
  490.  
  491. Object Make_Macro () {
  492.     Object mac;
  493.  
  494.     mac = Alloc_Object (sizeof (struct S_Macro), T_Macro, 0);
  495.     MACRO(mac)->body = MACRO(mac)->name = Null;
  496.     return mac;
  497. }
  498.  
  499. Object P_Macro (argl) Object argl; {
  500.     Object mac, body;
  501.     GC_Node2;
  502.  
  503.     mac = Null;
  504.     GC_Link2 (argl, mac);
  505.     mac = Make_Macro ();
  506.     body = Cons (Sym_Macro, argl);
  507.     MACRO(mac)->body = body;
  508.     Check_Formals (argl, &MACRO(mac)->min_args, &MACRO(mac)->max_args);
  509.     GC_Unlink;
  510.     return mac;
  511. }
  512.  
  513. Object P_Macro_Body (m) Object m; {
  514.     Check_Type (m, T_Macro);
  515.     return Copy_List (MACRO(m)->body);
  516. }
  517.  
  518. Object Macro_Expand (mac, argl) Object mac, argl; {
  519.     register argc, min, max, i, tail_calling = 0;
  520.     Object frame, ret, tail;
  521.     Object newframe; /* not used; see Lambda_Bind() */
  522.     GC_Node4;
  523.     TC_Prolog;
  524.  
  525.     frame = tail = Null;
  526.     GC_Link4 (argl, frame, tail, mac);
  527.     argc = Arglist_Length (argl);
  528.     min = MACRO(mac)->min_args;
  529.     max = MACRO(mac)->max_args;
  530.     if (argc < min)
  531.     Primitive_Error ("too few arguments for ~s", mac);
  532.     if (max >= 0 && argc > max)
  533.     Primitive_Error ("too many arguments for ~s", mac);
  534.     tail = Car (Cdr (MACRO(mac)->body));
  535.     for (i = 0; i < min; i++, tail = Cdr (tail), argl = Cdr (argl))
  536.     Lambda_Bind (Car (tail), Car (argl));
  537.     if (max == -1)
  538.     Lambda_Bind (tail, argl);
  539.     Push_Frame (frame);
  540.     TC_Disable;
  541.     ret = Begin (Cdr (Cdr (MACRO(mac)->body)));
  542.     TC_Enable;
  543.     Pop_Frame ();
  544.     GC_Unlink;
  545.     return ret;
  546. }
  547.  
  548. Object P_Macro_Expand (form) Object form; {
  549.     Object ret, mac;
  550.     GC_Node;
  551.  
  552.     Check_Type (form, T_Pair);
  553.     GC_Link (form);
  554.     mac = Eval (Car (form));
  555.     if (TYPE(mac) != T_Macro)
  556.     ret = form;
  557.     else
  558.     ret = Macro_Expand (mac, Cdr (form));
  559.     GC_Unlink;
  560.     return ret;
  561. }
  562.